{- -}
module HixayGraph where

import XI.Directory.Types
import Data.Ord
import Control.Arrow
import Data.Maybe
import Data.List
import Text.Dot
--import Data.Traversable hiding (mapM)

data CommParty = String deriving (Show)
type BusinessSystem = String 
data BusinessComponent = Maybe CommParty String deriving (Show)
data CommComponent = BusinessSystem | BusinessComponent deriving (Show)
type CommChannel = String
data CollabProfileItem = CollabProfileItem (Maybe CommParty) CommComponent CommChannel 
                         deriving (Show) 


planarizeChains :: [Chain] -> [ChainPlain]
planarizeChains cs = [ChainPlain {
            ps_sys      = s_sys sender,
            ps_cc       = s_cc sender,
            ps_int      = s_int sender,
            pmapping    = mapping rcv_int,
            pr_int      = r_int rcv_int,
            pr_cc       = r_cc rcv_int,
            pr_sys      = r_sys receiver
        } | 
        chain <- cs,
        sender <- [chain_sender chain],
        receiver <- chain_receivers chain,
        rcv_int <- r_ints receiver
    ]


dotBS x = node [("label", x), ("shape", "box"), ("style", "rounded")]
dotCC x = node [("label", x)]
dotI x = node [("label", x), ("shape", "box"), ("fontname", "Courier")]
dotCC2 x = node [("color", "red"), ("style", "filled"), ("label", x)]

dotChains :: [ChainPlain] -> Dot ()
dotChains cs = do
    mapM_ attribute [("rankdir","LR"), ("fontsize","8"), ("fontname","Arial"), ("dpi", "100")]
    sInt <- mapM (dotI . toShort . ps_int) cs
    rInt <- mapM (dotI . toShort . pr_int) cs
--    mapM (\(x,y,z) -> edge x y z) (zip3 sInt rInt $ map ((:[]) . ((,) "label"). toShort . fromMaybe "" . pmapping) cs)
    sequence_ $ zipWith3 edge sInt rInt $ map ((:[]) . ((,) "label"). toShort . fromMaybe "" . pmapping) cs
    sS <- mapM dotBS lSS
    sCC <- mapM dotCC lSCC
    mapM_ (\(x,y) -> (sS!!x) .->. (sCC!!y)) $ xsi lSS lSCC (nub $ map (ps_sys &&& ps_cc) cs)
    mapM_ (\(x,y) -> (sCC!!x) .->. y) $ xsj lSCC (lSCCi sInt)
    rS <- mapM dotBS lRS
    rCC <- mapM dotCC lRCC
    mapM_ (\(x,y) -> (rCC!!x) .->. (rS!!y)) $ xsi lRCC lRS (nub $ map (pr_cc &&& pr_sys) cs)
    mapM_ (\(x,y) -> y .->. (rCC!!x) ) $ xsj lRCC (lRCCi rInt)

    mapM_ (\(x,y) -> dotCC2 y) lSCC2
    -- return ()
    where
        lSS = nub $ map ps_sys cs  -- Sender systems
        lSCC = nub $ map ps_cc cs  -- Sender CC
        lSCCi q = zip (map ps_cc cs) q
        lRS = nub $ map pr_sys cs
        lRCC = nub $ map pr_cc cs
        lRCCi q = zip (map pr_cc cs) q

        xsi l1 l2 xs = map (fromJust *** fromJust) $ filter (flip all (map (isJust .) [fst, snd]) . flip ($)) $ map (flip elemIndex l1 *** flip elemIndex l2) xs
        xsj l1 xs = map (fromJust *** id) $ filter (isJust . fst) $ map (flip elemIndex l1 *** id) xs

        lSCC2 = nub $ map (\x -> (ps_sys x, ps_cc x)) cs
        

--flats = planarizeChains (allChains scenarios)
dotChainsString :: [Chain] -> String
dotChainsString = showDot . dotChains . planarizeChains

dot_sys :: Bool -> String -> Dot NodeId
dot_sys is_s s = node [("label", (if is_s then "Sender" else "Receiver") ++ ":\n" ++ s)]

dot_cc :: Bool -> String -> Dot NodeId 
dot_cc is_s s = node [("label", (if is_s then "Sender" else "Receiver") ++ "CC:\n" ++ s)]

dot_int :: Bool -> String -> Dot NodeId 
dot_int is_s s = node [("label", (if is_s then "Sender" else "Receiver") ++ "Int:\n" ++ s)]

flipper is_s = if is_s then id else flip

dot_sys_cc :: Bool -> NodeId -> NodeId -> Dot ()
dot_sys_cc is_s sys cc = flipper is_s (.->.) sys cc

dot_cc_int :: Bool -> NodeId -> NodeId -> Dot ()
dot_cc_int is_s cc int = flipper is_s (.->.) cc int

dot_map :: Bool -> NodeId -> NodeId -> Maybe String -> Dot ()
dot_map is_s int1 int2 str = flipper is_s edge int1 int2 (map ((,) "label") $ maybeToList str)

toShort = reverse . takeWhile (/='/') . reverse

